Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/vb4comms/dwcomm.cls

Text File | 1996-03-27 | 19.0 KB | 524 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "dwComm"
Attribute VB_Creatable = True
Attribute VB_Exposed = False
' dwDCB - Device Communication Block utility class
' Part of the Desaware API Class Library
' Copyright (c) 1996 by Desaware.
' All Rights Reserved
Option Explicit

Private Type COMMTIMEOUTS
        ReadIntervalTimeout As Long
        ReadTotalTimeoutMultiplier As Long
        ReadTotalTimeoutConstant As Long
        WriteTotalTimeoutMultiplier As Long
        WriteTotalTimeoutConstant As Long
End Type

Private Type OVERLAPPED
        Internal As Long
        InternalHigh As Long
        offset As Long
        OffsetHigh As Long
        hEvent As Long
End Type

' Private members
Private timeouts As COMMTIMEOUTS
Private handle As Long  ' Comm handle
Private devname$ ' Com1, com2 or other compatible comm device

' Public members
Public DCB As dwDCB

' Current state indicators
' Holds output data that arrives while an output transfer is in progress
Private PendingOutput$
Private CurrentEventMask&   ' Non zero if events are being watched for
' Buffers for overlapped input and output
' Must take this approach due to VB's ability to move strings
Private CurrentInputBuffer&
Private CurrentOutputBuffer&
Private TriggeredEvents&    ' Variable to load with event results

' Three overlapped structures,
' 0 = read, 1 = write, 2 = waitevent
Private overlaps(2) As OVERLAPPED
' Indicates background operation is in progress
Private inprogress(2) As Boolean
' Amount of data transferred on write
Private DataWritten&
Private DataRead&
Private EventResults&

' This object must have two functions
' CommInput(dev As dwComm, info As String)
' CommEvent(dev As dwComm, event as long)
Private CallbackObject As Object

' Declarations
Private Declare Function apiSetCommTimeouts Lib "kernel32" Alias "SetCommTimeouts" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function apiGetCommTimeouts Lib "kernel32" Alias "GetCommTimeouts" (ByVal hFile As Long, lpCommTimeouts As COMMTIMEOUTS) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, ByVal lpSecurityAttributes As Long, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Long) As Long
Private Declare Function SetupComm Lib "kernel32" (ByVal hFile As Long, ByVal dwInQueue As Long, ByVal dwOutQueue As Long) As Long
Private Declare Function GetCommModemStatus Lib "kernel32" (ByVal hFile As Long, lpModemStat As Long) As Long
Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function lstrcpyFromBuffer Lib "kernel32" Alias "lstrcpynA" (ByVal lpString1 As String, ByVal buffer As Long, ByVal iMaxLength As Long) As Long
Private Declare Function lstrcpyToBuffer Lib "kernel32" Alias "lstrcpynA" (ByVal buffer As Long, ByVal lpString2 As String, ByVal iMaxLength As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As String) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function CreateEvent Lib "kernel32" Alias "CreateEventA" (ByVal lpEventAttributes As Long, ByVal bManualReset As Long, ByVal bInitialState As Long, ByVal lpName As String) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As Long, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As OVERLAPPED) As Long
Private Declare Function SetCommMask Lib "kernel32" (ByVal hFile As Long, ByVal dwEvtMask As Long) As Long
Private Declare Function ClearCommError Lib "kernel32" (ByVal hFile As Long, lpErrors As Long, ByVal l As Long) As Long
Private Declare Function WaitCommEvent Lib "kernel32" (ByVal hFile As Long, lpEvtMask As Long, lpOverlapped As OVERLAPPED) As Long

Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const FILE_FLAG_OVERLAPPED = &H40000000
Private Const INVALID_HANDLE_VALUE = -1
Private Const GMEM_FIXED = &H0
Private Const ClassBufferSizes% = 1024
Private Const ERROR_IO_PENDING = 997 '  dderror
Private Const WAIT_TIMEOUT = &H102&

' GetCommModemStatus flags
Private Const MS_CTS_ON = &H10&
Private Const MS_DSR_ON = &H20&
Private Const MS_RING_ON = &H40&
Private Const MS_RLSD_ON = &H80&

' Error values
Private Const CLASS_NAME$ = "dwComm"
Private Const ERR_NOCOMMACCESS = 31010
Private Const ERR_UNINITIALIZED = 31011
Private Const ERR_MODEMSTATUS = 31012
Private Const ERR_READFAIL = 31013
Private Const ERR_EVENTFAIL = 31014

Private Const EV_RXCHAR = &H1                '  Any Character received
Private Const EV_RXFLAG = &H2                '  Received certain character
Private Const EV_TXEMPTY = &H4               '  Transmitt Queue Empty
Private Const EV_CTS = &H8                   '  CTS changed state
Private Const EV_DSR = &H10                  '  DSR changed state
Private Const EV_RLSD = &H20                 '  RLSD changed state
Private Const EV_BREAK = &H40                '  BREAK received
Private Const EV_ERR = &H80                  '  Line status error occurred
Private Const EV_RING = &H100                '  Ring signal detected
Private Const EV_PERR = &H200                '  Printer error occured
Private Const EV_RX80FULL = &H400            '  Receive buffer is 80 percent full
Private Const EV_EVENT1 = &H800              '  Provider specific event 1
Private Const EV_EVENT2 = &H1000             '  Provider specific event 2

Private Const CE_RXOVER = &H1                '  Receive Queue overflow
Private Const CE_OVERRUN = &H2               '  Receive Overrun Error
Private Const CE_RXPARITY = &H4              '  Receive Parity Error
Private Const CE_FRAME = &H8                 '  Receive Framing error
Private Const CE_BREAK = &H10                '  Break Detected
Private Const CE_TXFULL = &H100              '  TX Queue is full

' An empty string with a single null character
Private EmptyString As String * 1

Private Sub Class_Initialize()
    Dim olnum%
    Set DCB = New dwDCB
    CurrentInputBuffer = GlobalAlloc(GMEM_FIXED, ClassBufferSizes + 1)
    CurrentOutputBuffer = GlobalAlloc(GMEM_FIXED, ClassBufferSizes + 1)
    CurrentEventMask = EV_ERR
    EmptyString = Chr$(0)
    ' Create event objects for the background transfer
    For olnum = 0 To 2
        overlaps(olnum).hEvent = CreateEvent(0, True, False, vbNullString)
    Next olnum
End Sub

Private Sub Class_Terminate()
    Dim olnum
    ' Close existing comm device
    Call CloseComm
    ' Dump the event objects
    For olnum = 0 To 2
        Call CloseHandle(overlaps(olnum).hEvent)
    Next olnum
    Set DCB = Nothing   ' Be sure DCB is free
    Call GlobalFree(CurrentInputBuffer)
    Call GlobalFree(CurrentOutputBuffer)

End Sub

' Useful error routines
Private Sub DeviceNotOpenedError()
    Err.Raise vbObjectError + ERR_UNINITIALIZED, CLASS_NAME, "Communication Device is not open"
End Sub

Private Sub ModemStatusError()
    Err.Raise vbObjectError + ERR_MODEMSTATUS, CLASS_NAME, "GetCommModemStatus Failed"
End Sub


'-----------------------------------------------
' Timeout property access follows
'-----------------------------------------------
Public Property Get ReadIntervalTimeout() As Long
    ReadIntervalTimeout = timeouts.ReadIntervalTimeout
End Property

Public Property Let ReadIntervalTimeout(vNewValue As Long)
    timeouts.ReadIntervalTimeout = vNewValue
End Property

Public Property Get ReadTotalTimeoutMultiplier() As Long
    ReadTotalTimeoutMultiplier = timeouts.ReadTotalTimeoutMultiplier
End Property

Public Property Let ReadTotalTimeoutMultiplier(vNewValue As Long)
    timeouts.ReadTotalTimeoutMultiplier = vNewValue
End Property


Public Property Get ReadTotalTimeoutConstant() As Long
    ReadTotalTimeoutConstant = timeouts.ReadTotalTimeoutConstant
End Property

Public Property Let ReadTotalTimeoutConstant(vNewValue As Long)
    timeouts.ReadTotalTimeoutConstant = ReadTotalTimeoutConstant
End Property

Public Property Get WriteTotalTimeoutMultiplier() As Long
    WriteTotalTimeoutMultiplier = timeouts.WriteTotalTimeoutMultiplier
End Property

Public Property Let WriteTotalTimeoutMultiplier(vNewValue As Long)
    timeouts.WriteTotalTimeoutMultiplier = WriteTotalTimeoutMultiplier
End Property

Public Property Get WriteTotalTimeoutConstant() As Long
    WriteTotalTimeoutConstant = timeouts.WriteTotalTimeoutConstant
End Property

Public Property Let WriteTotalTimeoutConstant(vNewValue As Long)
    timeouts.WriteTotalTimeoutConstant = WriteTotalTimeoutConstant
End Property

' The device handle is read only
Public Property Get hCommDev() As Long
    hCommDev = handle
End Property

' This property is read only
Public Property Get DeviceName() As String
    DeviceName = devname
End Property

Public Sub GetCommTimeouts()
    ' Is there any real need to report errors here?
    If handle = 0 Then Exit Sub
    Call apiGetCommTimeouts(handle, timeouts)
End Sub

Public Function SetCommTimeouts() As Long
    If handle = 0 Then Exit Function ' Returns false
    SetCommTimeouts = apiSetCommTimeouts(handle, timeouts) <> 0
End Function

' The main function for opening a comm device
' Receives device name (com?) and optionally the size of the internal input and output queues
Public Function OpenComm(CommDeviceName As String, Notify As Object, Optional cbInQueue, Optional cbOutQueue) As Long
    ' Close an existing port when reopening
    If handle <> 0 Then CloseComm
    devname = CommDeviceName
    Set CallbackObject = Notify
    handle = CreateFile(devname, GENERIC_READ Or GENERIC_WRITE, 0, 0, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0)
    If handle = INVALID_HANDLE_VALUE Then Err.Raise vbObjectError + ERR_NOCOMMACCESS, CLASS_NAME, "Unable to open communications device"
    ' If the input and output queue size is specified, set it now
    If Not (IsMissing(cbInQueue) Or IsMissing(cbOutQueue)) Then
        Call SetupComm(handle, cbInQueue, cbOutQueue)
    Else
        Call SetupComm(handle, 8192, 1024)
    End If
    ' Ok, we've got the comm port. Initialize the timeouts
    GetCommTimeouts
    ' Set some default timeouts
    timeouts.ReadIntervalTimeout = 1
    timeouts.ReadTotalTimeoutMultiplier = 0
    timeouts.ReadTotalTimeoutConstant = 10
    timeouts.WriteTotalTimeoutMultiplier = 1
    timeouts.WriteTotalTimeoutConstant = 1
    SetCommTimeouts
    ' Initialize the DCB to the current device parameters
    Call DCB.GetCommState(Me)
    Call SetCommMask(handle, CurrentEventMask)
    StartInput
End Function

' Close the comm port
Public Function CloseComm() As Long
    ' Already closed, just exit
    If handle = 0 Then Exit Function
    Set CallbackObject = Nothing
    Call CloseHandle(handle)
    handle = 0
End Function



' This is another entry to retreive the comm state
' Note how it handles the problem of DCB needing the
' dwComm object parameter
Public Function GetCommState() As Long
    If handle = 0 Then DeviceNotOpenedError
    GetCommState = DCB.GetCommState(Me)
End Function

' This is another entry to retrieve the comm state
' Note how it handles the problem of DCB needing the
' dwComm object parameter
Public Function SetCommState() As Long
    If handle = 0 Then DeviceNotOpenedError
    SetCommState = DCB.SetCommState(Me)
End Function

' Here are some easy functions to determine the current
' modem status

Public Property Get CTS_ON()
    Dim modemstatus&
    Dim res&
    If handle = 0 Then DeviceNotOpenedError
    res = GetCommModemStatus(handle, modemstatus)
    If res = 0 Then ModemStatusError
    CTS_ON = (modemstatus And MS_CTS_ON) <> 0
End Property


Public Property Get DSR_ON()
    Dim modemstatus&
    Dim res&
    If handle = 0 Then DeviceNotOpenedError
    res = GetCommModemStatus(handle, modemstatus)
    If res = 0 Then ModemStatusError
    DSR_ON = (modemstatus And MS_DSR_ON) <> 0

End Property


Public Property Get RING_ON()
    Dim modemstatus&
    Dim res&
    If handle = 0 Then DeviceNotOpenedError
    res = GetCommModemStatus(handle, modemstatus)
    If res = 0 Then ModemStatusError
    RING_ON = (modemstatus And MS_RING_ON) <> 0

End Property


Public Property Get RLSD_ON()
    Dim modemstatus&
    Dim res&
    If handle = 0 Then DeviceNotOpenedError
    res = GetCommModemStatus(handle, modemstatus)
    If res = 0 Then ModemStatusError
    RLSD_ON = (modemstatus And MS_RLSD_ON) <> 0
End Property



' Data output Function
Public Function CommOutput(outputdata As String) As Long
    Dim bytestosend&
    Dim res&
    Dim addnull As Boolean
    If handle = 0 Then DeviceNotOpenedError
    PendingOutput = PendingOutput & outputdata
    If inprogress(1) Then    ' Write operation is in progress
        CommOutput = True
        Exit Function
    End If
    ' Start a new output operation
    bytestosend = Len(PendingOutput)
    ' No data to send, just exit
    If bytestosend = 0 Then
        CommOutput = True
        Exit Function
    End If
    ' Don't overflow our buffer
    If bytestosend > ClassBufferSizes Then bytestosend = ClassBufferSizes
    ' If there is a null character, just send up to the null
    If lstrlen(PendingOutput) < bytestosend Then
        ' but mark that we should send the null as well
        bytestosend = lstrlen(PendingOutput)
        addnull = True
    End If

    If bytestosend > 0 Then Call lstrcpyToBuffer(CurrentOutputBuffer, PendingOutput, bytestosend + 1)
    If bytestosend = Len(PendingOutput) Then
        PendingOutput = ""
    Else
        PendingOutput = Mid(PendingOutput, bytestosend + 1)
    End If
    If addnull Then bytestosend = bytestosend + 1
    res = WriteFile(handle, CurrentOutputBuffer, bytestosend, DataWritten, overlaps(1))
    If res <> 0 Then
        ProcessWriteComplete
        CommOutput = True
    Else
        If GetLastError() = ERROR_IO_PENDING Then
            inprogress(1) = True
            CommOutput = True
            #If DEBUGMODE Then
               Debug.Print "Pended write"
            #End If
        End If
    End If
End Function

' Restart the next output operation if necessary
Public Sub ProcessWriteComplete()
    inprogress(1) = False
    Call CommOutput("")
End Sub

' Called periodically
Public Sub PollWrite()
    Dim res&
    If Not inprogress(1) Then Exit Sub
    ' Check the event
    res = WaitForSingleObject(overlaps(1).hEvent, 0)
    ' If not yet signaled, just exit
    If res = WAIT_TIMEOUT Then Exit Sub
    ' Data was written - Try writing any pending data
    ProcessWriteComplete
End Sub

' This function enables or disables data transfer
Private Sub StartInput()
    Dim res&
    ' Read already in progress
    If inprogress(0) Then Exit Sub
    If handle = 0 Then DeviceNotOpenedError
    res = ReadFile(handle, CurrentInputBuffer, ClassBufferSizes, DataRead, overlaps(0))
    If res <> 0 Then
        ProcessReadComplete
    Else
        If GetLastError() = ERROR_IO_PENDING Then
            inprogress(0) = True
            #If DEBUGMODE Then
               Debug.Print "pended read"
            #End If
        Else
            Err.Raise vbObjectError + ERR_READFAIL, CLASS_NAME, "Failure on Comm device read operation"
        End If
    End If
End Sub

Public Sub PollRead()
    Dim res&
    If Not inprogress(0) Then
        StartInput
        Exit Sub
    End If

    ' Check the event
    res = WaitForSingleObject(overlaps(0).hEvent, 0)
    ' If not yet signaled, just exit
    If res = WAIT_TIMEOUT Then Exit Sub
    ' Data was written - Try writing any pending data
    ProcessReadComplete
End Sub

Public Sub ProcessReadComplete()
    Dim resstring$
    Dim copied&
    If inprogress(0) Then ' Was overlapped
        DataRead = overlaps(0).InternalHigh
        inprogress(0) = False
    End If
    If DataRead <> 0 Then
      #If DEBUGMODE Then
        Debug.Print "Read " & DataRead & " bytes"
      #End If
        resstring$ = String$(DataRead + 1, 0)
        copied = lstrcpyFromBuffer(resstring, CurrentInputBuffer, DataRead + 1)
        If Not (CallbackObject Is Nothing) Then
            Call CallbackObject.CommInput(Me, Left$(resstring, DataRead))
        End If
    End If
End Sub

Private Sub StartEventWatch()
    Dim res&
    ' Read already in progress
    If inprogress(2) Then Exit Sub
    If handle = 0 Then DeviceNotOpenedError
    EventResults = 0
    res = WaitCommEvent(handle, EventResults, overlaps(2))
    If res <> 0 Then
        ProcessEventComplete
    Else
        If GetLastError() = ERROR_IO_PENDING Then
            inprogress(2) = True
            #If DEBUGMODE Then
               Debug.Print "pended event"
            #End If
        Else
            Err.Raise vbObjectError + ERR_EVENTFAIL, CLASS_NAME, "Failure on Comm device event test operation"
        End If
    End If
End Sub

Private Sub ProcessEventComplete()
    Dim errors&
    If inprogress(2) Then ' Was overlapped
        inprogress(2) = False
    End If

    If EventResults <> 0 Then
        #If DEBUGMODE Then
         Debug.Print "Event value " & Hex$(EventResults)
         #End If
        If Not (CallbackObject Is Nothing) Then
            Call ClearCommError(handle, errors, 0)

            If (errors And CE_RXOVER) <> 0 Then Call CallbackObject.CommEvent(Me, "Receive Queue Full Error")
            If (errors And CE_OVERRUN) <> 0 Then Call CallbackObject.CommEvent(Me, "Receive Overrun Error")
            If (errors And CE_RXPARITY) <> 0 Then Call CallbackObject.CommEvent(Me, "Receive Parity Error")
            If (errors And CE_FRAME) <> 0 Then Call CallbackObject.CommEvent(Me, "Frame Error")
            If (errors And CE_BREAK) <> 0 Then Call CallbackObject.CommEvent(Me, "Break Detected")
            If (errors And CE_TXFULL) <> 0 Then Call CallbackObject.CommEvent(Me, "Transmit Queue Full")
        End If
    End If
End Sub

Private Sub PollEvent()
    Dim res&
    If Not inprogress(2) Then
        StartEventWatch
        Exit Sub
    End If

    ' Check the event
    res = WaitForSingleObject(overlaps(2).hEvent, 0)
    ' If not yet signaled, just exit
    If res = WAIT_TIMEOUT Then Exit Sub
    ' Data was written - Try writing any pending data
    ProcessEventComplete
End Sub

' Test results on all background processes
Public Sub Poll()
    PollWrite
    PollRead
    PollEvent
End Sub